Word clouds

% Remco Bloemen % 2015-08-26

Finding and weighing keywords

text = Import["~/text.txt"] // ToLowerCase;
text = StringReplace[text, {"educational" → "education","teachers" → "teacher","learner" → "student","technologies" → "technology","learning" → "learn","leerling" → "student","studenten" → "student","students" → "student","questions" → "question","levels" → "level"}];
tally = Tally@Cases[StringSplit[text,Except@LetterCharacter],_?(StringLength@#>4&)];
tally = Cases[tally,_?(Last@#>15&)];
tally = Reverse@SortBy[tally,Last];
range = {Min@(Last/@tally),Max@(Last/@tally)};
common = {"the","of","and","to","in","I","that","was","his","he","it","with","is","for","as","had","you","not","be","her","on","at","by","which","have","or","from","this","him","but","all","she","they","were","my","are","me","one","their","so","an","said","them","we","who","would","been","will","no","when","there","if","more","out","up","into","do","any","your","what","has","man","could","other","than","our","some","very","time","upon","about","may","its","only","now","like","little","then","can","should","made","did","us","such","a","great","before","must","two","these","see","know","over","much","down","after","first","mr","good","men","worden","around","based","where","current","because","become","means","already","possible","through","every","using","kunnen","within","wordt","first","second","binnen","while"};
tally = DeleteCases[tally, w_/; MemberQ[common,w[[1]]]];

Adding color and rotation

words = Style[First@#, FontFamily -> "Times",
     FontColor ->
      Hue[RandomReal[], RandomReal[{.5, 1}], RandomReal[{.5, 1}]],
     FontSize -> (Last@Rescale[#, range, {12, 150}])] & /@ tally;

wordsimg =
  ImagePad[#, -3 -
      BorderDimensions[#]] & /@ (Image[
       Graphics[Text[Framed[#, FrameMargins -> 2]]]] & /@ words);

angles = Join[{0, 0, 0}, RandomReal[{-Pi/4, Pi/4}, 5],
   RandomReal[{-Pi/2, Pi/2}, Length[wordsimg] - 3 - 5]];
wordsimgRot =
  ImageRotate[##, Background -> White] & @@@
   Transpose[{wordsimg, angles}];

Tightly packing objects

iteration2[img1_, w_, fun_: (Norm[#1 - #2] &)] :=
 Module[{imdil, centre, diff, dimw, padding, padded1, minpos},
  dimw = ImageDimensions[w];
  padded1 = ImagePad[img1, {dimw[[1]] {1, 1}, dimw[[2]] {1, 1}}, 1];
  imdil =
   Binarize[
    ImageCorrelate[Binarize[ColorNegate[padded1], 0.05],
     Dilation[Binarize[ColorNegate[w], 0.05], 5]]];
  centre = ImageDimensions[padded1]/2;
  minpos =
   Reverse@Nearest[Position[Reverse[ImageData[imdil]], 0],
      Reverse[centre], DistanceFunction -> fun][[1]];
  Sow[minpos - centre];(*for creating vector plot*)
  diff = ImageDimensions[imdil] - dimw;
  padding[pos_] := Transpose[{#, diff - #} &@Round[pos - dimw/2]];
  ImagePad[#, (-Min[#] {1, 1}) & /@ BorderDimensions[#]] &@
   ImageMultiply[padded1, ImagePad[w, padding[minpos], 1]]]

poslist =
 Reap[img = Fold[iteration2, wordsimgRot[[1]], Rest[wordsimgRot]];][[
  2, 1]]

The crux of the algorithm is a call to ImageCorrelate.

Converting back to vector

We now have coordinates for the bitmap images. We re-use these coordinates to create new Text entries. This is to convert it back to a vector image.

Graphics[MapThread[
  Text[#1, Offset[#2, {0, 0}], {0, 0}, {Cos[#3], Sin[#3]}] &, {words,
   Prepend[poslist, {0, 0}], angles}]]

See also

https://mathematica.stackexchange.com/questions/2334/how-to-create-word-clouds